home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / rel-8-patches.lisp < prev    next >
Text File  |  1990-06-07  |  10KB  |  256 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ZL-USER; Base: 10; Patch-File: T -*-
  2.  
  3. ;=====================================
  4. (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
  5. (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:l-COMPILER;OPTIMIZE.LISP.179")
  6. (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
  7.   "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
  8.  
  9. ;;; Does simple constant folding.  This works for everything that doesn't have
  10. ;;; side-effects.
  11. ;;; ALL operands must be constant.
  12. ;;; Note that commutative-constant-folder can hack this case perfectly well
  13. ;;; by himself for the functions he handles.
  14. (defun constant-fold-optimizer (form)
  15.   (let ((eval-when-load-p nil))
  16.     (flet ((constant-form-p (x)
  17.          (when (constant-form-p x)
  18.            (cond ((and (listp x)
  19.                (eq (car x) 'quote)
  20.                (listp (cadr x))
  21.                (eq (caadr x) eval-at-load-time-marker))
  22.               (setq eval-when-load-p t)
  23.               (cdadr x))
  24.              (t x)))))
  25.       (if (every (cdr form) #'constant-form-p)
  26.       (if eval-when-load-p
  27.           (list 'quote
  28.             (list* eval-at-load-time-marker
  29.                (car form)
  30.                (mapcar #'constant-form-p (cdr form))))
  31.           (condition-case (error-object)
  32.            (multiple-value-call #'(lambda (&rest values)
  33.                         (if (= (length values) 1)
  34.                         `',(first values)
  35.                         `(values ,@(mapcar #'(lambda (x) `',x)
  36.                                    values))))
  37.                     (eval form))
  38.          (error
  39.            (phase-1-warning "Constant form left unoptimized: ~S~%because: ~~A~"
  40.                     form error-object)
  41.            form)))
  42.       form))))
  43.  
  44.  
  45. ;=====================================
  46. (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
  47. (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:L-COMPILER;COMFILE.LISP.85")
  48. (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
  49.   "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
  50.  
  51. ;;;
  52. ;;; The damn compiler doesn't compile random forms that appear at top level.
  53. ;;; Its difficult to do because you have to get an associated function spec
  54. ;;; to go with those forms.  This handles that by defining a special form,
  55. ;;; top-level-form that compiles its body.  It takes a list of eval-when
  56. ;;; times just like eval when does.  It also takes a name which it uses
  57. ;;; to construct a function spec for the top-level-form function it has
  58. ;;; to create.
  59. ;;; 
  60. ;
  61. ;si::
  62. ;(defvar *top-level-form-fdefinitions* (cl:make-hash-table :test #'equal))
  63. ;
  64. ;si::
  65. ;(define-function-spec-handler pcl::top-level-form
  66. ;                  (operation fspec &optional arg1 arg2)
  67. ;  (let ((name (cadr fspec)))
  68. ;    (selectq operation
  69. ;      (validate-function-spec (and (= (length fspec) 2)
  70. ;                   (or (symbolp name)
  71. ;                       (listp name))))
  72. ;      (fdefine
  73. ;       (setf (gethash name *top-level-form-fdefinitions*) arg1))
  74. ;      ((fdefinition fdefinedp)
  75. ;       (gethash name *top-level-form-fdefinitions*)) 
  76. ;      (fdefinition-location 
  77. ;       (ferror "It is not possible to get the fdefinition-location of ~s."
  78. ;           fspec))
  79. ;      (fundefine (remhash name *top-level-form-fdefinitions*))
  80. ;      (otherwise (function-spec-default-handler operation fspec arg1 arg2)))))
  81. ;
  82. ;;;
  83. ;;; This is basically stolen from PROGN (surprised?)
  84. ;;; 
  85. ;(si:define-special-form pcl::top-level-form (name times
  86. ;                          &body body
  87. ;                          &environment env)
  88. ;  (declare lt:(arg-template . body) (ignore name))
  89. ;  (si:check-eval-when-times times)
  90. ;  (when (member 'eval times) (si:eval-body body env)))
  91. ;
  92. ;(defun (:property pcl::top-level-form lt:mapforms) (original-form form usage)
  93. ;  (lt::mapforms-list original-form form (cddr form) 'eval usage))
  94.  
  95. ;;; This is the normal function for looking at each form read from the file and calling
  96. ;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it.
  97. ;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time.  It is
  98. ;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...).
  99. ;(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL))
  100. ;  (CATCH-ERROR-RESTART
  101. ;     (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM)
  102. ;    (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA)))
  103. ;      (LET ((ERROR-MESSAGE-HOOK
  104. ;          #'(LAMBDA ()
  105. ;          (DECLARE (SYS:DOWNWARD-FUNCTION))
  106. ;          (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\"
  107. ;              DBG:*ERROR-MESSAGE-PRINLEVEL*
  108. ;              DBG:*ERROR-MESSAGE-PRINLENGTH*
  109. ;              FORM))))
  110. ;    (SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM)))
  111. ;      (WHEN (LISTP FORM)            ;Ignore atoms at top-level
  112. ;    (LET ((FUNCTION (FIRST FORM)))
  113. ;      (SELECTQ FUNCTION
  114. ;        ((QUOTE))                ;and quoted constants e.g. 'COMPILE
  115. ;        ((PROGN)
  116. ;         (DOLIST (FORM (CDR FORM))
  117. ;           (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)))
  118. ;        ((EVAL-WHEN)
  119. ;         (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM))
  120. ;         (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM))
  121. ;                  (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM)))))
  122. ;           (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM))))
  123. ;           (FORMS (CDDR FORM)))
  124. ;           (COND (LOAD-P
  125. ;              (DOLIST (FORM FORMS)
  126. ;            (COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE))))
  127. ;             (COMPILE-P
  128. ;              (DOLIST (FORM FORMS)
  129. ;            (FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL))))))
  130. ;        ((DEFUN)
  131. ;         (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T)))
  132. ;           (IF (EQ (CDR TEM) (CDR FORM))
  133. ;           (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)
  134. ;           (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO))))
  135. ;        ((MACRO)
  136. ;         (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T))
  137. ;        ((DECLARE)
  138. ;         (DOLIST (FORM (CDR FORM))
  139. ;           (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T)
  140. ;            ;; (DECLARE (SPECIAL ... has load-time action as well.
  141. ;            ;; All other DECLARE's do not.
  142. ;            (MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL)))))
  143. ;        ((COMPILER-LET)
  144. ;         (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM)
  145. ;                    #'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO))
  146. ;        ((SI:DEFINE-SPECIAL-FORM)
  147. ;         (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))
  148. ;        ((MULTIPLE-DEFINITION)
  149. ;         (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM)
  150. ;           (LET ((NAME-VALID (AND (NOT (NULL NAME))
  151. ;                      (OR (SYMBOLP NAME)
  152. ;                      (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE)))))
  153. ;             (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE))))
  154. ;         (UNLESS (AND NAME-VALID TYPE-VALID)
  155. ;           (WARN "(~S ~S ~S ...) is invalid because~@
  156. ;              ~:[~S is not valid as a definition name~;~*~]~
  157. ;              ~:[~&~S is not valid as a definition type~;~*~]"
  158. ;             'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE)))
  159. ;           (LET* ((COMPILED-BODY NIL)
  160. ;              (COMPILE-FUNCTION *COMPILE-FUNCTION*)
  161. ;              (*COMPILE-FUNCTION*
  162. ;            (LAMBDA (OPERATION &REST ARGS)
  163. ;              (DECLARE (SYS:DOWNWARD-FUNCTION))
  164. ;              (SELECTQ OPERATION
  165. ;                (:DUMP-FORM
  166. ;                 (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM
  167. ;                        (FIRST ARGS))
  168. ;                   COMPILED-BODY))
  169. ;                (:INSTALL-DEFINITION
  170. ;                 (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS))
  171. ;                   COMPILED-BODY))
  172. ;                (OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS)))))
  173. ;              (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE)
  174. ;                        ,@LOCAL-DECLARATIONS)))
  175. ;         (DOLIST (FORM BODY)
  176. ;           (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))
  177. ;         (FUNCALL COMPILE-FUNCTION :DUMP-FORM
  178. ;              `(LOAD-MULTIPLE-DEFINITION
  179. ;                 ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL)))))
  180. ;        ((pcl::top-level-form)
  181. ;         (destructuring-bind (name times . body)
  182. ;                 (cdr form)
  183. ;           (si:check-eval-when-times times)
  184. ;           (let ((compile-p (or (memq 'compile times)
  185. ;                    (and compile-time-too (memq 'eval times))))
  186. ;             (load-p (or (memq 'load times)
  187. ;                 (memq 'cl:load times)))
  188. ;             (fspec `(pcl::top-level-form ,name)))
  189. ;         (cond (load-p
  190. ;            (compile-from-stream-1
  191. ;              `(progn (defun ,fspec () . ,body)
  192. ;                  (funcall (function ,fspec)))
  193. ;              (and compile-p ':force)))
  194. ;               (compile-p
  195. ;            (dolist (b body)
  196. ;              (funcall *compile-form-function* form ':force nil)))))))
  197. ;        (OTHERWISE
  198. ;         (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM))))
  199. ;           (IF TEM
  200. ;           (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T)
  201. ;           (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))))))))))
  202. ;
  203. ;
  204.  
  205.  
  206. dw::
  207. (defun symbol-flavor-or-cl-type (symbol)
  208.   (declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent
  209.            non-atomic-deftype))
  210.   (multiple-value-bind (result foundp)
  211.       (gethash symbol *flavor-or-cl-type-cache*)
  212.     (let ((frob
  213.         (if foundp result
  214.           (setf (gethash symbol *flavor-or-cl-type-cache*)
  215.             (or (get symbol 'flavor:flavor)
  216.             (let ((class (get symbol 'clos-internals::class-for-name)))
  217.               (when (and class
  218.                      (not (typep class 'clos:built-in-class)))
  219.                 class))
  220.             (not (null (defstruct-type-p symbol)))
  221.             (let* ((deftype (get symbol 'deftype))
  222.                    (descriptor (symbol-presentation-type-descriptor symbol))
  223.                    (typep
  224.                  (unless (and descriptor
  225.                           (presentation-type-explicit-type-function
  226.                         descriptor))
  227.                    ;; Don't override the one defined in the presentation-type.
  228.                    (get symbol 'typep)))
  229.                    (atomic-subtype-parent (find-atomic-subtype-parent symbol))
  230.                    (non-atomic-deftype
  231.                  (when (and (not descriptor) deftype)
  232.                    (not (member (first (type-arglist symbol))
  233.                         '(&rest &key &optional))))))
  234.               (if (or typep (not (atom deftype))
  235.                   non-atomic-deftype
  236.                   ;; deftype overrides atomic-subtype-parent.
  237.                   (and (not deftype) atomic-subtype-parent))
  238.                   (list-in-area *handler-dynamic-area*
  239.                         deftype typep atomic-subtype-parent
  240.                         non-atomic-deftype)
  241.                 deftype)))))))
  242.       (locally (declare (inline compiled-function-p))
  243.         (etypecase frob
  244.       (array (values frob))
  245.       (instance (values frob))
  246.       (null (values nil))
  247.       ((member t) (values nil t))
  248.       (compiled-function (values nil nil frob))
  249.       (lexical-closure (values nil nil frob))
  250.       (list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype)
  251.             frob
  252.           (values nil nil deftype typep atomic-subtype-parent non-atomic-deftype)))
  253.       (symbol (values nil nil nil nil frob)))))))
  254.  
  255.  
  256.